home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / c / hash.d < prev    next >
Text File  |  1987-06-03  |  9KB  |  402 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. #include "include.h"
  8.  
  9. object Seq;
  10. object Seql;
  11. object Sequal;
  12.  
  13. object Ktest;
  14. object Ksize;
  15. object Krehash_size;
  16. object Krehash_threshold;
  17.  
  18.  
  19. int
  20. hash_eql(x)
  21. object x;
  22. {
  23.     int h;
  24.  
  25.     switch (type_of(x)) {
  26.     case t_fixnum:
  27.         return(fix(x));
  28.  
  29.     case t_bignum:
  30.         h = x->big.big_car;
  31.         while (x->big.big_cdr != NULL) {
  32.             x = (object)x->big.big_cdr;
  33.             h += x->big.big_car;
  34.         }
  35.         return(h);
  36.  
  37.     case t_ratio:
  38.            return(hash_eql(x->rat.rat_num) + hash_eql(x->rat.rat_den));
  39.  
  40.     case t_shortfloat:
  41.         return((int)(sf(x)));
  42.  
  43.     case t_longfloat:
  44.         return((int)(lf(x)) + *((int *)x + 1));
  45.  
  46.     case t_complex:
  47.         return(hash_eql(x->cmp.cmp_real) + hash_eql(x->cmp.cmp_imag));
  48.  
  49.     case t_character:
  50.         return(char_code(x));
  51.  
  52.     default:
  53.         return((int)x / 4);
  54.     }
  55. }
  56.  
  57. int
  58. hash_equal(x)
  59. object x;
  60. {
  61.     int h = 0, i;
  62.     char *s;
  63.  
  64.     cs_check(x);
  65.  
  66. BEGIN:
  67.     switch (type_of(x)) {
  68.     case t_cons:
  69.         h += hash_equal(x->c.c_car);
  70.         x = x->c.c_cdr;
  71.         goto BEGIN;
  72.  
  73.     case t_string:
  74.         for (i = x->st.st_fillp, s = x->st.st_self;  i > 0;  --i, s++)
  75.             h += (*s & 0377)*12345 + 1;
  76.         return(h);
  77.  
  78.     case t_bitvector:
  79.         return(h);
  80.  
  81.     case t_pathname:
  82.         h += hash_equal(x->pn.pn_host);
  83.         h += hash_equal(x->pn.pn_device);
  84.         h += hash_equal(x->pn.pn_directory);
  85.         h += hash_equal(x->pn.pn_name);
  86.         h += hash_equal(x->pn.pn_type);
  87.         h += hash_equal(x->pn.pn_version);
  88.         return(h);
  89.  
  90.     case t_structure:
  91.         h += hash_equal(x->str.str_name);
  92.         for (i = 0;  i < x->str.str_length;  i++)
  93.             h += hash_equal(x->str.str_self[i]);
  94.         return(h);
  95.  
  96.     default:
  97.         return(h + hash_eql(x));
  98.     }
  99. }
  100.         
  101. struct htent *
  102. gethash(key, hashtable)
  103. object key;
  104. object hashtable;
  105. {
  106.     enum httest htest;
  107.     int hsize;
  108.     struct htent *e;
  109.     object hkey;
  110.     int i, j = -1, k; /* k added by chou */
  111.     bool b;
  112.  
  113.     htest = (enum httest)hashtable->ht.ht_test;
  114.     hsize = hashtable->ht.ht_size;
  115.     if (htest == htt_eq)
  116.         i = (int)key / 4;
  117.     else if (htest == htt_eql)
  118.         i = hash_eql(key);
  119.     else if (htest == htt_equal)
  120.         i = hash_equal(key);
  121.     i &= 0x7fffffff;
  122.     for (i %= hsize, k = 0; k < hsize;  i = (i + 1) % hsize, k++) { /* k added by chou */
  123.         e = &hashtable->ht.ht_self[i];
  124.         hkey = e->hte_key;
  125.         if (hkey == OBJNULL) {
  126.             if (e->hte_value == OBJNULL)
  127.                 if (j < 0)
  128.                     return(e);
  129.                 else
  130.                     return(&hashtable->ht.ht_self[j]);
  131.             else
  132.                 if (j < 0)
  133.                     j = i;
  134.                 else
  135.                     ;
  136.             continue;
  137.         }
  138.         if (htest == htt_eq)
  139.                 b = key == hkey;
  140.         else if (htest == htt_eql)
  141.             b = eql(key, hkey);
  142.         else if (htest == htt_equal)
  143.             b = equal(key, hkey);
  144.         if (b)
  145.             return(&hashtable->ht.ht_self[i]);
  146.     }
  147.     return(&hashtable->ht.ht_self[j]);    /* added by chou */
  148. }
  149.  
  150. sethash(key, hashtable, value)
  151. object key, hashtable, value;
  152. {
  153.     int i;
  154.     bool over;
  155.     struct htent *e;
  156.     
  157.     i = hashtable->ht.ht_nent + 1;
  158.     if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum)
  159.         over = i >= fix(hashtable->ht.ht_rhthresh);
  160.     else if (type_of(hashtable->ht.ht_rhthresh) == t_shortfloat)
  161.         over =
  162.         i >= hashtable->ht.ht_size * sf(hashtable->ht.ht_rhthresh);
  163.     else if (type_of(hashtable->ht.ht_rhthresh) == t_longfloat)
  164.         over =
  165.         i >= hashtable->ht.ht_size * lf(hashtable->ht.ht_rhthresh);
  166.     if (over)
  167.         extend_hashtable(hashtable);
  168.     e = gethash(key, hashtable);
  169.     if (e->hte_key == OBJNULL)
  170.         hashtable->ht.ht_nent++;
  171.     e->hte_key = key;
  172.     e->hte_value = value;
  173. }
  174.     
  175. extend_hashtable(hashtable)
  176. object hashtable;
  177. {
  178.     object old;
  179.     short new_size, i;
  180.  
  181.     if (type_of(hashtable->ht.ht_rhsize) == t_fixnum)
  182.         new_size = 
  183.         hashtable->ht.ht_size + fix(hashtable->ht.ht_rhsize);
  184.     else if (type_of(hashtable->ht.ht_rhsize) == t_shortfloat)
  185.         new_size = 
  186.         hashtable->ht.ht_size * sf(hashtable->ht.ht_rhsize);
  187.     else if (type_of(hashtable->ht.ht_rhsize) == t_longfloat)
  188.         new_size = 
  189.         hashtable->ht.ht_size * lf(hashtable->ht.ht_rhsize);
  190.     old = alloc_object(t_hashtable);
  191.     old->ht = hashtable->ht;
  192.     vs_push(old);
  193.     hashtable->ht.ht_self = NULL;
  194.     hashtable->ht.ht_size = new_size;
  195.     if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum)
  196.         hashtable->ht.ht_rhthresh =
  197.         make_fixnum(fix(hashtable->ht.ht_rhthresh) +
  198.                 (new_size - old->ht.ht_size));
  199.     hashtable->ht.ht_self =
  200.     (struct htent *)alloc_relblock(new_size * sizeof(struct htent));
  201.     for (i = 0;  i < new_size;  i++) {
  202.         hashtable->ht.ht_self[i].hte_key = OBJNULL;
  203.         hashtable->ht.ht_self[i].hte_value = OBJNULL;
  204.     }
  205.     for (i = 0;  i < old->ht.ht_size;  i++) {
  206.         if (old->ht.ht_self[i].hte_key != OBJNULL)
  207.             sethash(old->ht.ht_self[i].hte_key,
  208.                 hashtable,
  209.                 old->ht.ht_self[i].hte_value);
  210.     }
  211.     hashtable->ht.ht_nent = old->ht.ht_nent;
  212.     vs_pop;
  213. }
  214.  
  215.  
  216. @(defun make_hash_table (&key (test Seql)
  217.                   (size `make_fixnum(1024)`)
  218.                   (rehash_size
  219.                    `make_shortfloat((shortfloat)1.5)`)
  220.                   (rehash_threshold
  221.                    `make_shortfloat((shortfloat)0.7)`)
  222.              &aux h)
  223.     enum httest htt;
  224.     int i;
  225. @
  226.     if (test == Seq || test == Seq->s.s_gfdef)
  227.         htt = htt_eq;
  228.     else if (test == Seql || test == Seql->s.s_gfdef)
  229.         htt = htt_eql;
  230.     else if (test == Sequal || test == Sequal->s.s_gfdef)
  231.         htt = htt_equal;
  232.     else
  233.         FEerror("~S is an illegal hash-table test function.",
  234.             1, test);
  235.       if (type_of(size) != t_fixnum || 0 < fix(size))
  236.         ;
  237.     else
  238.         FEerror("~S is an illegal hash-table size.", 1, size);
  239.     if (type_of(rehash_size) == t_fixnum && 0 < fix(rehash_size) ||
  240.         type_of(rehash_size) == t_shortfloat && 1.0 < sf(rehash_size) ||
  241.         type_of(rehash_size) == t_longfloat && 1.0 < lf(rehash_size))
  242.         ;
  243.     else
  244.         FEerror("~S is an illegal hash-table rehash-size.",
  245.             1, rehash_size);
  246.     if (type_of(rehash_threshold) == t_fixnum &&
  247.         0 < fix(rehash_threshold) && fix(rehash_threshold) < fix(size) ||
  248.         type_of(rehash_threshold) == t_shortfloat &&
  249.         0.0 < sf(rehash_threshold) && sf(rehash_threshold) < 1.0 ||
  250.         type_of(rehash_threshold) == t_longfloat &&
  251.         0.0 < lf(rehash_threshold) && lf(rehash_threshold) < 1.0)
  252.         ;
  253.     else
  254.         FEerror("~S is an illegal hash-table rehash-threshold.",
  255.             1, rehash_threshold);
  256.     h = alloc_object(t_hashtable);
  257.     h->ht.ht_test = (short)htt;
  258.     h->ht.ht_size = fix(size);
  259.     h->ht.ht_rhsize = rehash_size;
  260.     h->ht.ht_rhthresh = rehash_threshold;
  261.         h->ht.ht_nent = 0;
  262.     h->ht.ht_self = NULL;
  263.     h->ht.ht_self = (struct htent *)
  264.     alloc_relblock(fix(size) * sizeof(struct htent));
  265.     for(i = 0;  i < fix(size);  i++) {
  266.         h->ht.ht_self[i].hte_key = OBJNULL;
  267.         h->ht.ht_self[i].hte_value = OBJNULL;
  268.     }
  269.     @(return h)
  270. @)
  271.  
  272. Lhash_table_p()
  273. {
  274.     check_arg(1);
  275.  
  276.     if(type_of(vs_base[0]) == t_hashtable)
  277.         vs_base[0] = Ct;
  278.     else   
  279.         vs_base[0] = Cnil;
  280. }
  281.  
  282. Lgethash()
  283. {
  284.     int narg;
  285.     struct htent *e;
  286.     
  287.     narg = vs_top - vs_base;
  288.     if (narg < 2)
  289.         too_few_arguments();
  290.     else if (narg == 2)
  291.         vs_push(Cnil);
  292.     else if (narg > 3)
  293.         too_many_arguments();
  294.     check_type_hash_table(&vs_base[1]);
  295.     e = gethash(vs_base[0], vs_base[1]);
  296.     if (e->hte_key != OBJNULL) {
  297.         vs_base[0] = e->hte_value;
  298.         vs_base[1] = Ct;
  299.     } else {
  300.         vs_base[0] = vs_base[2];
  301.         vs_base[1] = Cnil;
  302.     }
  303.     vs_pop;
  304. }
  305.  
  306. siLhash_set()
  307. {
  308.     check_arg(3);
  309.  
  310.     check_type_hash_table(&vs_base[1]);
  311.     sethash(vs_base[0], vs_base[1], vs_base[2]);
  312.     vs_base += 2;
  313. }
  314.     
  315. Lremhash()
  316. {
  317.     struct htent *e;
  318.  
  319.     check_arg(2);
  320.     check_type_hash_table(&vs_base[1]);
  321.     e = gethash(vs_base[0], vs_base[1]);
  322.     if (e->hte_key != OBJNULL) {
  323.         e->hte_key = OBJNULL;
  324.         e->hte_value = Cnil;
  325.         vs_base[1]->ht.ht_nent--;
  326.         vs_base[0] = Ct;
  327.     } else
  328.         vs_base[0] = Cnil;
  329.     vs_top = vs_base + 1;
  330. }
  331.  
  332. Lclrhash()
  333. {
  334.     int i;
  335.  
  336.     check_arg(1);
  337.     check_type_hash_table(&vs_base[0]);
  338.     for(i = 0; i < vs_base[0]->ht.ht_size; i++) {
  339.         vs_base[0]->ht.ht_self[i].hte_key = OBJNULL;
  340.         vs_base[0]->ht.ht_self[i].hte_value = OBJNULL;
  341.     }
  342.     vs_base[0]->ht.ht_nent = 0;
  343. }
  344.  
  345. Lhash_table_count()
  346. {
  347.     object z;
  348.  
  349.     check_arg(1);
  350.     check_type_hash_table(&vs_base[0]);
  351.     vs_base[0] = make_fixnum(vs_base[0]->ht.ht_nent);
  352. }
  353.  
  354.  
  355. Lsxhash()
  356. {
  357.     check_arg(1);
  358.  
  359.     vs_base[0] = make_fixnum(hash_equal(vs_base[0]) & 0x7fffffff);
  360. }
  361.  
  362. Lmaphash()
  363. {
  364.     object *base = vs_base;
  365.         object hashtable;
  366.     int i;
  367.  
  368.     check_arg(2);
  369.     check_type_hash_table(&vs_base[1]);
  370.     hashtable = vs_base[1];
  371.     for (i = 0;  i < hashtable->ht.ht_size;  i++) {
  372.         if(hashtable->ht.ht_self[i].hte_key != OBJNULL)
  373.             ifuncall2(base[0],
  374.                   hashtable->ht.ht_self[i].hte_key,
  375.                   hashtable->ht.ht_self[i].hte_value);
  376.     }
  377.     vs_base[0] = Cnil;
  378.     vs_pop;
  379. }
  380.  
  381.  
  382. init_hash()
  383. {
  384.     Seq = make_ordinary("EQ");
  385.     Seql = make_ordinary("EQL");
  386.     Sequal = make_ordinary("EQUAL");
  387.     Ksize = make_keyword("SIZE");
  388.     Ktest = make_keyword("TEST");
  389.     Krehash_size = make_keyword("REHASH-SIZE");
  390.     Krehash_threshold = make_keyword("REHASH-THRESHOLD");
  391.     
  392.     make_function("MAKE-HASH-TABLE", Lmake_hash_table);
  393.     make_function("HASH-TABLE-P", Lhash_table_p);
  394.     make_function("GETHASH", Lgethash);
  395.     make_function("REMHASH", Lremhash);
  396.        make_function("MAPHASH", Lmaphash);
  397.     make_function("CLRHASH", Lclrhash);
  398.     make_function("HASH-TABLE-COUNT", Lhash_table_count);
  399.        make_function("SXHASH", Lsxhash);
  400.     make_si_function("HASH-SET", siLhash_set);
  401. }
  402.